Builds with and without OsPath build flag.
Unfortunately, the test suite fails.
Sponsored-by: unqueued on Patreon
{- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp
- when HTTPS is enabled -}
-gitAnnexWebCertificate :: Git.Repo -> FilePath
-gitAnnexWebCertificate r = fromOsPath $
- gitAnnexDir r </> literalOsPath "certificate.pem"
-gitAnnexWebPrivKey :: Git.Repo -> FilePath
-gitAnnexWebPrivKey r = fromOsPath $
- gitAnnexDir r </> literalOsPath "privkey.pem"
+gitAnnexWebCertificate :: Git.Repo -> OsPath
+gitAnnexWebCertificate r = gitAnnexDir r </> literalOsPath "certificate.pem"
+gitAnnexWebPrivKey :: Git.Repo -> OsPath
+gitAnnexWebPrivKey r = gitAnnexDir r </> literalOsPath "privkey.pem"
{- .git/annex/feeds/ is used to record per-key (url) state by importfeed -}
gitAnnexFeedStateDir :: Git.Repo -> OsPath
{- This is the base directory name used by the assistant when making
- repositories, by default. -}
-gitAnnexAssistantDefaultDir :: FilePath
-gitAnnexAssistantDefaultDir = "annex"
+gitAnnexAssistantDefaultDir :: OsPath
+gitAnnexAssistantDefaultDir = literalOsPath "annex"
gitAnnexSimDir :: Git.Repo -> OsPath
gitAnnexSimDir r = addTrailingPathSeparator $
else pure "git-annex"
p <- if isAbsolute (toOsPath exe)
then return exe
- else fromMaybe exe <$> readProgramFile
+ else maybe exe fromOsPath <$> readProgramFile
maybe cannotFindProgram return =<< searchPath p
reqgitannex name
isgitannex = flip M.notMember otherMulticallCommands
{- Returns the path for git-annex that is recorded in the programFile. -}
-readProgramFile :: IO (Maybe FilePath)
+readProgramFile :: IO (Maybe OsPath)
readProgramFile = catchDefaultIO Nothing $ do
programfile <- programFile
- headMaybe . lines <$> readFile (fromOsPath programfile)
+ fmap toOsPath . headMaybe . lines <$> readFile (fromOsPath programfile)
cannotFindProgram :: IO a
cannotFindProgram = do
import Network.Socket (HostName, PortNumber)
stopDaemon :: Annex ()
-stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath
- =<< fromRepo gitAnnexPidFile
+stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
{- Starts the daemon. If the daemon is run in the foreground, once it's
- running, can start the browser.
-
- startbrowser is passed the url and html shim file, as well as the original
- stdout and stderr descriptors. -}
-startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
+startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber -> Maybe (Maybe Handle -> Maybe Handle -> String -> OsPath -> IO ()) -> Annex ()
startDaemon assistant foreground startdelay cannotrun listenhost listenport startbrowser = do
Annex.changeState $ \s -> s { Annex.daemon = True }
enableInteractiveBranchAccess
pidfile <- fromRepo gitAnnexPidFile
logfile <- fromRepo gitAnnexDaemonLogFile
- liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile
+ liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile
createAnnexDirectory (parentDir pidfile)
#ifndef mingw32_HOST_OS
createAnnexDirectory (parentDir logfile)
- let logfd = handleToFd =<< openLog (fromRawFilePath logfile)
+ let logfd = handleToFd =<< openLog (fromOsPath logfile)
if foreground
then do
origout <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdOutput
origerr <- liftIO $ catchMaybeIO $
fdToHandle =<< dup stdError
- let undaemonize = Utility.Daemon.foreground logfd (Just (fromRawFilePath pidfile))
+ let undaemonize = Utility.Daemon.foreground logfd (Just pidfile)
start undaemonize $
case startbrowser of
Nothing -> Nothing
Just a -> Just $ a origout origerr
else do
- git_annex <- liftIO programPath
+ git_annex <- fromOsPath <$> liftIO programPath
ps <- gitAnnexDaemonizeParams
- start (Utility.Daemon.daemonize git_annex ps logfd (Just (fromRawFilePath pidfile)) False) Nothing
+ start (Utility.Daemon.daemonize git_annex ps logfd (Just pidfile) False) Nothing
#else
-- Windows doesn't daemonize, but does redirect output to the
-- log file. The only way to do so is to restart the program.
createAnnexDirectory (parentDir logfile)
ifM (liftIO $ isNothing <$> getEnv flag)
( liftIO $ withNullHandle $ \nullh -> do
- loghandle <- openLog (fromRawFilePath logfile)
+ loghandle <- openLog (fromOsPath logfile)
e <- getEnvironment
cmd <- programPath
ps <- getArgs
exitcode <- withCreateProcess p $ \_ _ _ pid ->
waitForProcess pid
exitWith exitcode
- , start (Utility.Daemon.foreground (Just (fromRawFilePath pidfile))) $
+ , start (Utility.Daemon.foreground (Just (fromOsPath pidfile))) $
case startbrowser of
Nothing -> Nothing
Just a -> Just $ a Nothing Nothing
checkCanWatch
dstatus <- startDaemonStatus
logfile <- fromRepo gitAnnexDaemonLogFile
- liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile
+ liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromOsPath logfile
liftIO $ daemonize $
flip runAssistant (go webappwaiter)
=<< newAssistantData st dstatus
maxfilesshown = 10
(!somefiles, !counter) = splitcounter (dedupadjacent files)
- !shortfiles = map (fromString . shortFile . takeFileName) somefiles
+ !shortfiles = map (fromString . shortFile . fromOsPath . takeFileName . toOsPath) somefiles
renderer alert = tenseWords $ msg : alertData alert ++ showcounter
where
import Control.Concurrent.STM
{- Handlers call this when they made a change that needs to get committed. -}
-madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change)
+madeChange :: OsPath -> ChangeInfo -> Assistant (Maybe Change)
madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t)
noChange :: Assistant (Maybe Change)
noChange = return Nothing
{- Indicates an add needs to be done, but has not started yet. -}
-pendingAddChange :: FilePath -> Assistant (Maybe Change)
+pendingAddChange :: OsPath -> Assistant (Maybe Change)
pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pure f)
{- Gets all unhandled changes.
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Assistant.Install where
import System.PosixCompat.Files (ownerExecuteMode)
import qualified Data.ByteString.Char8 as S8
-standaloneAppBase :: IO (Maybe FilePath)
-standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
+standaloneAppBase :: IO (Maybe OsPath)
+standaloneAppBase = fmap toOsPath <$> getEnv "GIT_ANNEX_APP_BASE"
{- The standalone app does not have an installation process.
- So when it's run, it needs to set up autostarting of the assistant
, go =<< standaloneAppBase
)
where
- go Nothing = installFileManagerHooks "git-annex"
+ go Nothing = installFileManagerHooks (literalOsPath "git-annex")
go (Just base) = do
- let program = base </> "git-annex"
+ let program = base </> literalOsPath "git-annex"
programfile <- programFile
- createDirectoryIfMissing True $
- fromRawFilePath (parentDir (toRawFilePath programfile))
- writeFile programfile program
+ createDirectoryIfMissing True (parentDir programfile)
+ writeFile (fromOsPath programfile) (fromOsPath program)
#ifdef darwin_HOST_OS
autostartfile <- userAutoStart osxAutoStartLabel
( do
-- Integration with the Termux:Boot app.
home <- myHomeDir
- let bootfile = home </> ".termux" </> "boot" </> "git-annex"
+ let bootfile = toOsPath home </> literalOsPath ".termux" </> literalOsPath "boot" </> literalOsPath "git-annex"
unlessM (doesFileExist bootfile) $ do
createDirectoryIfMissing True (takeDirectory bootfile)
- writeFile bootfile "git-annex assistant --autostart"
+ writeFile (fromOsPath bootfile) "git-annex assistant --autostart"
, do
menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
icondir <- iconDir <$> userDataDir
- installMenu program menufile base icondir
+ installMenu (fromOsPath program) menufile base icondir
autostartfile <- autoStartPath "git-annex" <$> userConfigDir
- installAutoStart program autostartfile
+ installAutoStart (fromOsPath program) autostartfile
)
#endif
sshdir <- sshDir
- let runshell var = "exec " ++ base </> "runshell " ++ var
+ let runshell var = "exec " ++ fromOsPath (base </> literalOsPath "runshell ") ++ var
let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
- installWrapper (toRawFilePath (sshdir </> "git-annex-shell")) $
+ installWrapper (sshdir </> literalOsPath "git-annex-shell") $
[ shebang
, "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
, rungitannexshell "$@"
, "fi"
]
- installWrapper (toRawFilePath (sshdir </> "git-annex-wrapper")) $
+ installWrapper (sshdir </> literalOsPath "git-annex-wrapper") $
[ shebang
, "set -e"
, runshell "\"$@\""
installFileManagerHooks program
-installWrapper :: RawFilePath -> [String] -> IO ()
+installWrapper :: OsPath -> [String] -> IO ()
installWrapper file content = do
let content' = map encodeBS content
- curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' (toOsPath file)
+ curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' file
when (curr /= content') $ do
- createDirectoryIfMissing True (fromRawFilePath (parentDir file))
- viaTmp F.writeFile' (toOsPath file) $
- linesFile' (S8.unlines content')
+ createDirectoryIfMissing True (parentDir file)
+ viaTmp F.writeFile' file $ linesFile' (S8.unlines content')
modifyFileMode file $ addModes [ownerExecuteMode]
-installFileManagerHooks :: FilePath -> IO ()
+installFileManagerHooks :: OsPath -> IO ()
#ifdef linux_HOST_OS
installFileManagerHooks program = unlessM osAndroid $ do
let actions = ["get", "drop", "undo"]
-- Gnome
- nautilusScriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir
+ nautilusScriptdir <- (\d -> d </> literalOsPath "nautilus" </> literalOsPath "scripts") <$> userDataDir
createDirectoryIfMissing True nautilusScriptdir
forM_ actions $
genNautilusScript nautilusScriptdir
-- KDE
userdata <- userDataDir
- let kdeServiceMenusdir = userdata </> "kservices5" </> "ServiceMenus"
+ let kdeServiceMenusdir = userdata </> literalOsPath "kservices5" </> literalOsPath "ServiceMenus"
createDirectoryIfMissing True kdeServiceMenusdir
- writeFile (kdeServiceMenusdir </> "git-annex.desktop")
+ writeFile (fromOsPath (kdeServiceMenusdir </> literalOsPath "git-annex.desktop"))
(kdeDesktopFile actions)
where
genNautilusScript scriptdir action =
- installscript (toRawFilePath (scriptdir </> scriptname action)) $ unlines
+ installscript (scriptdir </> toOsPath (scriptname action)) $ unlines
[ shebang
, autoaddedcomment
- , "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
+ , "exec " ++ fromOsPath program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
]
scriptname action = "git-annex " ++ action
installscript f c = whenM (safetoinstallscript f) $ do
- writeFile (fromRawFilePath f) c
+ writeFile (fromOsPath f) c
modifyFileMode f $ addModes [ownerExecuteMode]
safetoinstallscript f = catchDefaultIO True $
elem (encodeBS autoaddedcomment) . fileLines'
- <$> F.readFile' (toOsPath f)
+ <$> F.readFile' f
autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)"
autoaddedmsg = "Automatically added by git-annex, do not edit."
, "Icon=git-annex"
, unwords
[ "Exec=sh -c 'cd \"$(dirname \"$1\")\" &&"
- , program
+ , fromOsPath program
, command
, "--notify-start --notify-finish -- \"$1\"'"
, "false" -- this becomes $0 in sh, so unused
{- Makes a new git repository. Or, if a git repository already
- exists, returns False. -}
-makeRepo :: FilePath -> Bool -> IO Bool
+makeRepo :: OsPath -> Bool -> IO Bool
makeRepo path bare = ifM (probeRepoExists path)
( return False
, do
where
baseparams = [Param "init", Param "--quiet"]
params
- | bare = baseparams ++ [Param "--bare", File path]
- | otherwise = baseparams ++ [File path]
+ | bare = baseparams ++ [Param "--bare", File (fromOsPath path)]
+ | otherwise = baseparams ++ [File (fromOsPath path)]
{- Runs an action in the git repository in the specified directory. -}
-inDir :: FilePath -> Annex a -> IO a
+inDir :: OsPath -> Annex a -> IO a
inDir dir a = do
state <- Annex.new
=<< Git.Config.read
- =<< Git.Construct.fromPath (toRawFilePath dir)
+ =<< Git.Construct.fromPath dir
Annex.eval state $ a `finally` quiesce True
{- Creates a new repository, and returns its UUID. -}
-initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID
+initRepo :: Bool -> Bool -> OsPath -> Maybe String -> Maybe StandardGroup -> IO UUID
initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do
initRepo' desc mgroup
{- Initialize the master branch, so things that expect
Annex.Branch.commit =<< Annex.Branch.commitMessage
{- Checks if a git repo exists at a location. -}
-probeRepoExists :: FilePath -> IO Bool
+probeRepoExists :: OsPath -> IO Bool
probeRepoExists dir = isJust <$>
- catchDefaultIO Nothing (Git.Construct.checkForRepo (encodeBS dir))
+ catchDefaultIO Nothing (Git.Construct.checkForRepo dir)
{- Authorized keys are set up before pairing is complete, so that the other
- side can immediately begin syncing. -}
-setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
+setupAuthorizedKeys :: PairMsg -> OsPath -> IO ()
setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
Left err -> giveup err
Right pubkey -> do
- absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir)
+ absdir <- absPath repodir
unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $
giveup "failed setting up ssh authorized keys"
{ sshHostName = T.pack hostname
, sshUserName = Just (T.pack $ remoteUserName d)
, sshDirectory = T.pack dir
- , sshRepoName = genSshRepoName hostname dir
+ , sshRepoName = genSshRepoName hostname (toOsPath dir)
, sshPort = 22
, needsPubKey = True
, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]
#endif
import qualified Utility.Lsof as Lsof
import Utility.ThreadScheduler
-import qualified Utility.RawFilePath as R
+import qualified Utility.OsString as OS
import Control.Concurrent.Async
-import qualified Data.ByteString as S
-import qualified System.FilePath.ByteString as P
{- When the FsckResults require a repair, tries to do a non-destructive
- repair. If that fails, pops up an alert. -}
thisrepopath <- liftIO . absPath
=<< liftAnnex (fromRepo Git.repoPath)
a <- liftAnnex $ mkrepair $
- repair fsckresults (Just (fromRawFilePath thisrepopath))
+ repair fsckresults (Just (fromOsPath thisrepopath))
liftIO $ catchBoolIO a
repair fsckresults referencerepo = do
backgroundfsck params = liftIO $ void $ async $ do
program <- programPath
- batchCommand program (Param "fsck" : params)
+ batchCommand (fromOsPath program) (Param "fsck" : params)
{- Detect when a git lock file exists and has no git process currently
- writing to it. This strongly suggests it is a stale lock file.
repairStaleLocks lockfiles
return $ not $ null lockfiles
where
- findgitfiles = dirContentsRecursiveSkipping (== P.dropTrailingPathSeparator annexDir) True . Git.localGitDir
+ findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir
islock f
- | "gc.pid" `S.isInfixOf` f = False
- | ".lock" `S.isSuffixOf` f = True
- | P.takeFileName f == "MERGE_HEAD" = True
+ | literalOsPath "gc.pid" `OS.isInfixOf` f = False
+ | literalOsPath ".lock" `OS.isSuffixOf` f = True
+ | takeFileName f == literalOsPath "MERGE_HEAD" = True
| otherwise = False
-repairStaleLocks :: [RawFilePath] -> Assistant ()
+repairStaleLocks :: [OsPath] -> Assistant ()
repairStaleLocks lockfiles = go =<< getsizes
where
getsize lf = catchMaybeIO $ (\s -> (lf, s))
<$> getFileSize lf
getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
go [] = return ()
- go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromRawFilePath . fst) l))
+ go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromOsPath . fst) l))
( do
waitforit "to check stale git lock file"
l' <- getsizes
if l' == l
- then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . fst) l
+ then liftIO $ mapM_ (removeWhenExistsWith removeFile . fst) l
else go l'
, do
waitforit "for git lock file writer"
import Utility.Url
import Utility.Url.Parse
import Utility.PID
-import qualified Utility.RawFilePath as R
import qualified Git.Construct
import qualified Git.Config
import qualified Annex
prepRestart :: Assistant ()
prepRestart = do
liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
- liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexUrlFile)
- liftIO . removeWhenExistsWith R.removeLink =<< liftAnnex (fromRepo gitAnnexPidFile)
+ liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
+ liftIO . removeWhenExistsWith removeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
{- To finish a restart, send a global redirect to the new url
- to any web browsers that are displaying the webapp.
runRestart :: Assistant URLString
runRestart = liftIO . newAssistantUrl
- =<< liftAnnex (Git.repoLocation <$> Annex.gitRepo)
+ =<< liftAnnex (Git.repoPath <$> Annex.gitRepo)
{- Starts up the assistant in the repository, and waits for it to create
- a gitAnnexUrlFile. Waits for the assistant to be up and listening for
- connections by testing the url. -}
-newAssistantUrl :: FilePath -> IO URLString
+newAssistantUrl :: OsPath -> IO URLString
newAssistantUrl repo = do
startAssistant repo
geturl
where
geturl = do
- r <- Git.Config.read =<< Git.Construct.fromPath (toRawFilePath repo)
- waiturl $ fromRawFilePath $ gitAnnexUrlFile r
+ r <- Git.Config.read =<< Git.Construct.fromPath repo
+ waiturl $ gitAnnexUrlFile r
waiturl urlfile = do
- v <- tryIO $ readFile urlfile
+ v <- tryIO $ readFile (fromOsPath urlfile)
case v of
Left _ -> delayed $ waiturl urlfile
Right url -> ifM (assistantListening url)
- On windows, the assistant does not daemonize, which is why the forkIO is
- done.
-}
-startAssistant :: FilePath -> IO ()
+startAssistant :: OsPath -> IO ()
startAssistant repo = void $ forkIO $ do
- program <- programPath
- let p = (proc program ["assistant"]) { cwd = Just repo }
+ program <- fromOsPath <$> programPath
+ let p = (proc program ["assistant"]) { cwd = Just (fromOsPath repo) }
withCreateProcess p $ \_ _ _ pid -> void $ checkSuccessProcess pid
import Utility.SshHost
import Utility.Process.Transcript
import qualified Utility.FileIO as F
+import qualified Utility.OsString as OS
import Data.Text (Text)
import qualified Data.Text as T
{ sshHostName = T.pack host
, sshUserName = if null user then Nothing else Just $ T.pack user
, sshDirectory = T.pack dir
- , sshRepoName = genSshRepoName host dir
+ , sshRepoName = genSshRepoName host (toOsPath dir)
-- dummy values, cannot determine from url
, sshPort = 22
, needsPubKey = True
fromssh = mkdata . break (== '/')
{- Generates a git remote name, like host_dir or host -}
-genSshRepoName :: String -> FilePath -> String
+genSshRepoName :: String -> OsPath -> String
genSshRepoName host dir
- | null dir = makeLegalName host
- | otherwise = makeLegalName $ host ++ "_" ++ dir
+ | OS.null dir = makeLegalName host
+ | otherwise = makeLegalName $ host ++ "_" ++ fromOsPath dir
{- The output of ssh, including both stdout and stderr. -}
sshTranscript :: [String] -> SshHost -> String -> (Maybe String) -> IO (String, Bool)
where
(ssh, keytype) = separate (== '-') prefix
-addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
+addAuthorizedKeys :: Bool -> OsPath -> SshPubKey -> IO Bool
addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]
{- Should only be used within the same process that added the line;
- the layout of the line is not kepy stable across versions. -}
-removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
+removeAuthorizedKeys :: Bool -> OsPath -> SshPubKey -> IO ()
removeAuthorizedKeys gitannexshellonly dir pubkey = do
let keyline = authorizedKeysLine gitannexshellonly dir pubkey
sshdir <- sshDir
- The ~/.ssh/git-annex-shell wrapper script is created if not already
- present.
-}
-addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
+addAuthorizedKeysCommand :: Bool -> OsPath -> SshPubKey -> String
addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
[ "mkdir -p ~/.ssh"
, intercalate "; "
]
runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""
-authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String
+authorizedKeysLine :: Bool -> OsPath -> SshPubKey -> String
authorizedKeysLine gitannexshellonly dir pubkey
| gitannexshellonly = limitcommand ++ pubkey
{- TODO: Locking down rsync is difficult, requiring a rather
- long perl script. -}
| otherwise = pubkey
where
- limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty "
+ limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape (fromOsPath dir)++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty "
{- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair
liftAnnex $ do
-- Clean up anything left behind by a previous process
-- on unclean shutdown.
- void $ liftIO $ tryIO $ removeDirectoryRecursive
- (fromRawFilePath lockdowndir)
+ void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir
void $ createAnnexDirectory lockdowndir
waitChangeTime $ \(changes, time) -> do
- readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof largefilematcher annexdotfiles delayadd $
+ readychanges <- handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd $
simplifyChanges changes
if shouldCommit False time (length readychanges) readychanges
then do
- Any pending adds that are not ready yet are put back into the ChangeChan,
- where they will be retried later.
-}
-handleAdds :: FilePath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
+handleAdds :: OsPath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = returnWhen (null incomplete) $ do
let (pending, inprocess) = partition isPendingAddChange incomplete
let lockdownconfig = LockDownConfig
{ lockingFile = False
- , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
+ , hardlinkFileTmpDir = Just lockdowndir
, checkWritePerms = True
}
(postponed, toadd) <- partitionEithers
| otherwise = a
checkpointerfile change = do
- let file = toRawFilePath $ changeFile change
+ let file = changeFile change
mk <- liftIO $ isPointerFile file
case mk of
Nothing -> return (Right change)
Just key -> do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
+ mode <- liftIO $ catchMaybeIO $
+ fileMode <$> R.getFileStatus (fromOsPath file)
liftAnnex $ stagePointerFile file mode =<< hashPointerFile key
return $ Left $ Change
(changeTime change)
else checkmatcher
| otherwise = checkmatcher
where
- f = toRawFilePath (changeFile change)
+ f = changeFile change
checkmatcher = ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f)
( return (Left change)
, return (Right change)
addsmall [] = noop
addsmall toadd = liftAnnex $ void $ tryIO $
- forM (map (toRawFilePath . changeFile) toadd) $ \f ->
+ forM (map changeFile toadd) $ \f ->
Command.Add.addFile Command.Add.Small f
- =<< liftIO (R.getSymbolicLinkStatus f)
+ =<< liftIO (R.getSymbolicLinkStatus (fromOsPath f))
{- Avoid overhead of re-injesting a renamed unlocked file, by
- examining the other Changes to see if a removed file has the
delta <- liftAnnex getTSDelta
let cfg = LockDownConfig
{ lockingFile = False
- , hardlinkFileTmpDir = Just (toRawFilePath lockdowndir)
+ , hardlinkFileTmpDir = Just lockdowndir
, checkWritePerms = True
}
if M.null m
then forM toadd (addannexed' cfg)
else forM toadd $ \c -> do
- mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta
+ mcache <- liftIO $ genInodeCache (changeFile c) delta
case mcache of
Nothing -> addannexed' cfg c
Just cache ->
(mkey, _mcache) <- liftAnnex $ do
showStartMessage (StartMessage "add" (ActionItemOther (Just (QuotedPath (keyFilename ks)))) (SeekInput []))
ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing
- maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey
+ maybe (failedingest change) (done change $ keyFilename ks) mkey
addannexed' _ _ = return Nothing
fastadd :: Change -> Key -> Assistant (Maybe Change)
fastadd change key = do
let source = keySource $ lockedDown change
liftAnnex $ finishIngestUnlocked key source
- done change (fromRawFilePath $ keyFilename source) key
+ done change (keyFilename source) key
removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
removedKeysMap ct l = do
mks <- forM (filter isRmChange l) $ \c ->
- catKeyFile $ toRawFilePath $ changeFile c
+ catKeyFile $ changeFile c
M.fromList . concat <$> mapM mkpairs (catMaybes mks)
where
mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>
done change file key = liftAnnex $ do
logStatus NoLiveUpdate key InfoPresent
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file)
- stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
+ mode <- liftIO $ catchMaybeIO $
+ fileMode <$> R.getFileStatus (fromOsPath file)
+ stagePointerFile file mode =<< hashPointerFile key
showEndOk
return $ Just $ finishedChange change key
- and is still a hard link to its contentLocation,
- before ingesting it. -}
sanitycheck keysource a = do
- fs <- liftIO $ R.getSymbolicLinkStatus $ keyFilename keysource
- ks <- liftIO $ R.getSymbolicLinkStatus $ contentLocation keysource
+ fs <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ keyFilename keysource
+ ks <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath $ contentLocation keysource
if deviceID ks == deviceID fs && fileID ks == fileID fs
then a
else do
-- remove the hard link
when (contentLocation keysource /= keyFilename keysource) $
- void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation keysource
+ void $ liftIO $ tryIO $ removeFile $ contentLocation keysource
return Nothing
{- Shown an alert while performing an action to add a file or
- the add succeeded.
-}
addaction [] a = a
- addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $
+ addaction toadd a = alertWhile' (addFileAlert $ map (fromOsPath . changeFile) toadd) $
(,)
<$> pure True
<*> a
-
- Check by running lsof on the repository.
-}
-safeToAdd :: FilePath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
+safeToAdd :: OsPath -> LockDownConfig -> Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
safeToAdd _ _ _ _ [] [] = return []
safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
maybe noop (liftIO . threadDelaySeconds) delayadd
then S.fromList . map fst3 . filter openwrite <$>
findopenfiles (map (keySource . lockedDown) inprocess')
else pure S.empty
- let checked = map (check openfiles) inprocess'
+ let openfiles' = S.map toOsPath openfiles
+ let checked = map (check openfiles') inprocess'
{- If new events are received when files are closed,
- there's no need to retry any changes that cannot
else return checked
where
check openfiles change@(InProcessAddChange { lockedDown = ld })
- | S.member (fromRawFilePath (contentLocation (keySource ld))) openfiles = Left change
+ | S.member (contentLocation (keySource ld)) openfiles = Left change
check _ change = Right change
mkinprocess (c, Just ld) = Just InProcessAddChange
<> " still has writers, not adding"
-- remove the hard link
when (contentLocation ks /= keyFilename ks) $
- void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks
+ void $ liftIO $ tryIO $ removeFile $ contentLocation ks
canceladd _ = noop
openwrite (_file, mode, _pid)
findopenfiles keysources = ifM crippledFileSystem
( liftIO $ do
let segments = segmentXargsUnordered $
- map (fromRawFilePath . keyFilename) keysources
+ map (fromOsPath . keyFilename) keysources
concat <$> forM segments (\fs -> Lsof.query $ "--" : fs)
- , liftIO $ Lsof.queryDir lockdowndir
+ , liftIO $ Lsof.queryDir (fromOsPath lockdowndir)
)
{- After a Change is committed, queue any necessary transfers or drops
handleDrops "file renamed" present k af []
where
f = changeFile change
- af = AssociatedFile (Just (toRawFilePath f))
+ af = AssociatedFile (Just f)
checkChangeContent _ = noop
when (old /= new) $ do
let changedconfigs = new `S.difference` old
debug $ "reloading config" :
- map (fromRawFilePath . fst)
+ map (fromOsPath . fst)
(S.toList changedconfigs)
reloadConfigs new
{- Record a commit to get this config
loop new
{- Config files, and their checksums. -}
-type Configs = S.Set (RawFilePath, Sha)
+type Configs = S.Set (OsPath, Sha)
{- All git-annex's config files, and actions to run when they change. -}
-configFilesActions :: [(RawFilePath, Assistant ())]
+configFilesActions :: [(OsPath, Assistant ())]
configFilesActions =
[ (uuidLog, void $ liftAnnex uuidDescMapLoad)
, (remoteLog, void $ liftAnnex remotesChanged)
getConfigs = S.fromList . map extract
<$> liftAnnex (inRepo $ LsTree.lsTreeFiles (LsTree.LsTreeLong False) Annex.Branch.fullname files)
where
- files = map (fromRawFilePath . fst) configFilesActions
+ files = map (fromOsPath . fst) configFilesActions
extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem)
runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant ()
runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
- program <- liftIO programPath
+ program <- fromOsPath <$> liftIO programPath
g <- liftAnnex gitRepo
fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do
void $ batchCommand program (Param "fsck" : annexFsckParams d)
dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
dispatch (Just rmt) = void $ case Remote.remoteFsck rmt of
Nothing -> go rmt $ do
- program <- programPath
+ program <- fromOsPath <$> programPath
void $ batchCommand program $
[ Param "fsck"
-- avoid downloading files
import qualified Git.Branch
import qualified Git.Ref
import qualified Command.Sync
-
-import qualified System.FilePath.ByteString as P
+import qualified Utility.OsString as OS
{- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -}
mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo
let gitd = Git.localGitDir g
- let dir = gitd P.</> "refs"
+ let dir = gitd </> literalOsPath "refs"
liftIO $ createDirectoryUnder [gitd] dir
let hook a = Just <$> asIO2 (runHandler a)
changehook <- hook onChange
, modifyHook = changehook
, errHook = errhook
}
- void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
- debug ["watching", fromRawFilePath dir]
+ void $ liftIO $ watchDir dir (const False) True hooks id
+ debug ["watching", fromOsPath dir]
-type Handler = FilePath -> Assistant ()
+type Handler t = t -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
-runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -}
-onErr :: Handler
+onErr :: Handler String
onErr = giveup
{- Called when a new branch ref is written, or a branch ref is modified.
- ok; it ensures that any changes pushed since the last time the assistant
- ran are merged in.
-}
-onChange :: Handler
+onChange :: Handler OsPath
onChange file
- | ".lock" `isSuffixOf` file = noop
+ | literalOsPath ".lock" `OS.isSuffixOf` file = noop
| isAnnexBranch file = do
branchChanged
diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case
- to the second branch, which should be merged into it? -}
isRelatedTo :: Git.Ref -> Git.Ref -> Bool
isRelatedTo x y
- | basex /= takeDirectory basex ++ "/" ++ basey = False
+ | basex /= fromOsPath (takeDirectory (toOsPath basex)) ++ "/" ++ basey = False
| "/synced/" `isInfixOf` Git.fromRef x = True
| "refs/remotes/" `isPrefixOf` Git.fromRef x = True
| otherwise = False
basex = Git.fromRef $ Git.Ref.base x
basey = Git.fromRef $ Git.Ref.base y
-isAnnexBranch :: FilePath -> Bool
-isAnnexBranch f = n `isSuffixOf` f
+isAnnexBranch :: OsPath -> Bool
+isAnnexBranch f = n `isSuffixOf` fromOsPath f
where
n = '/' : Git.fromRef Annex.Branch.name
-fileToBranch :: FilePath -> Git.Ref
-fileToBranch f = Git.Ref $ encodeBS $ "refs" </> base
+fileToBranch :: OsPath -> Git.Ref
+fileToBranch f = Git.Ref $ fromOsPath $ literalOsPath "refs" </> toOsPath base
where
- base = Prelude.last $ split "/refs/" f
+ base = Prelude.last $ split "/refs/" (fromOsPath f)
handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant ()
handleMounts urlrenderer wasmounted nowmounted =
- mapM_ (handleMount urlrenderer . mnt_dir) $
+ mapM_ (handleMount urlrenderer . toOsPath . mnt_dir) $
S.toList $ newMountPoints wasmounted nowmounted
-handleMount :: UrlRenderer -> FilePath -> Assistant ()
+handleMount :: UrlRenderer -> OsPath -> Assistant ()
handleMount urlrenderer dir = do
- debug ["detected mount of", dir]
+ debug ["detected mount of", fromOsPath dir]
rs <- filterM (Git.repoIsLocal <$$> liftAnnex . Remote.getRepo)
=<< remotesUnder dir
mapM_ (fsckNudge urlrenderer . Just) rs
- at startup time, or may have changed (it could even be a different
- repository at the same remote location..)
-}
-remotesUnder :: FilePath -> Assistant [Remote]
+remotesUnder :: OsPath -> Assistant [Remote]
remotesUnder dir = do
repotop <- liftAnnex $ fromRepo Git.repoPath
rs <- liftAnnex remoteList
return $ mapMaybe snd $ filter fst pairs
where
checkremote repotop r = case Remote.localpath r of
- Just p | dirContains (toRawFilePath dir) (absPathFrom repotop (toRawFilePath p)) ->
+ Just p | dirContains dir (absPathFrom repotop p) ->
(,) <$> pure True <*> updateRemote r
_ -> return (False, Just r)
pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
pairAckReceived True (Just pip) msg cache = do
stopSending pip
- repodir <- fromRawFilePath . repoPath <$> liftAnnex gitRepo
+ repodir <- repoPath <$> liftAnnex gitRepo
liftIO $ setupAuthorizedKeys msg repodir
finishedLocalPairing msg (inProgressSshKeyPair pip)
startSending pip PairDone $ multicastPairMsg
remoteControlThread :: NamedThread
remoteControlThread = namedThread "RemoteControl" $ do
- program <- liftIO programPath
+ program <- liftIO $ fromOsPath <$> programPath
(cmd, params) <- liftIO $ toBatchCommand
(program, [Param "remotedaemon", Param "--foreground"])
let p = proc cmd (toCommand params)
ifM (not <$> liftAnnex (inRepo checkIndexFast))
( do
debug ["corrupt index file found at startup; removing and restaging"]
- liftAnnex $ inRepo $ removeWhenExistsWith R.removeLink . indexFile
+ liftAnnex $ inRepo $ removeWhenExistsWith removeFile . indexFile
{- Normally the startup scan avoids re-staging files,
- but with the index deleted, everything needs to be
- restaged. -}
- will be automatically regenerated. -}
unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do
debug ["corrupt annex/index file found at startup; removing"]
- liftAnnex $ liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexIndex
+ liftAnnex $ liftIO . removeWhenExistsWith removeFile =<< fromRepo gitAnnexIndex
{- Fix up ssh remotes set up by past versions of the assistant. -}
liftIO $ fixUpSshRemotes
batchmaker <- liftIO getBatchCommandMaker
-- Find old unstaged symlinks, and add them to git.
- (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False ["."] g
+ (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False [literalOsPath "."] g
now <- liftIO getPOSIXTime
forM_ unstaged $ \file -> do
- ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file
+ ms <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath file
case ms of
Just s | toonew (statusChangeTime s) now -> noop
- | isSymbolicLink s -> addsymlink (fromRawFilePath file) ms
+ | isSymbolicLink s -> addsymlink file ms
_ -> noop
liftIO $ void cleanup
{- Run git-annex unused once per day. This is run as a separate
- process to stay out of the annex monad and so it can run as a
- batch job. -}
- program <- liftIO programPath
+ program <- fromOsPath <$> liftIO programPath
let (program', params') = batchmaker (program, [Param "unused"])
void $ liftIO $ boolSystem program' params'
{- Invalidate unused keys cache, and queue transfers of all unused
void $ addAlert $ sanityCheckFixAlert msg
addsymlink file s = do
Watcher.runHandler Watcher.onAddSymlink file s
- insanity $ "found unstaged symlink: " ++ file
+ insanity $ "found unstaged symlink: " ++ fromOsPath file
hourlyCheck :: Assistant ()
hourlyCheck = do
-}
checkLogSize :: Int -> Assistant ()
checkLogSize n = do
- f <- liftAnnex $ fromRawFilePath <$> fromRepo gitAnnexDaemonLogFile
- logs <- liftIO $ listLogs f
- totalsize <- liftIO $ sum <$> mapM (getFileSize . toRawFilePath) logs
+ f <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
+ logs <- liftIO $ listLogs (fromOsPath f)
+ totalsize <- liftIO $ sum <$> mapM (getFileSize . toOsPath) logs
when (totalsize > 2 * oneMegabyte) $ do
debug ["Rotated logs due to size:", show totalsize]
- liftIO $ openLog f >>= handleToFd >>= redirLog
+ liftIO $ openLog (fromOsPath f) >>= handleToFd >>= redirLog
when (n < maxLogs + 1) $ do
- df <- liftIO $ getDiskFree $ takeDirectory f
+ df <- liftIO $ getDiskFree $ fromOsPath $ takeDirectory f
case df of
Just free
| free < fromIntegral totalsize ->
checkRepoExists :: Assistant ()
checkRepoExists = do
g <- liftAnnex gitRepo
- liftIO $ unlessM (doesDirectoryExist $ fromRawFilePath $ Git.repoPath g) $
+ liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $
terminateSelf
, modifyHook = modifyhook
, errHook = errhook
}
- void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
+ void $ liftIO $ watchDir dir (const False) True hooks id
debug ["watching for transfers"]
-type Handler = FilePath -> Assistant ()
+type Handler t = t -> Assistant ()
{- Runs an action handler.
-
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
-runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler :: Handler t -> t -> Maybe FileStatus -> Assistant ()
runHandler handler file _filestatus =
either (liftIO . print) (const noop) =<< tryIO <~> handler file
{- Called when there's an error with inotify. -}
-onErr :: Handler
+onErr :: Handler String
onErr = giveup
{- Called when a new transfer information file is written. -}
-onAdd :: Handler
-onAdd file = case parseTransferFile (toRawFilePath file) of
+onAdd :: Handler OsPath
+onAdd file = case parseTransferFile file of
Nothing -> noop
Just t -> go t =<< liftAnnex (checkTransfer t)
where
-
- The only thing that should change in the transfer info is the
- bytesComplete, so that's the only thing updated in the DaemonStatus. -}
-onModify :: Handler
-onModify file = case parseTransferFile (toRawFilePath file) of
+onModify :: Handler OsPath
+onModify file = case parseTransferFile file of
Nothing -> noop
- Just t -> go t =<< liftIO (readTransferInfoFile Nothing (toRawFilePath file))
+ Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
where
go _ Nothing = noop
go t (Just newinfo) = alterTransferInfo t $
watchesTransferSize = modifyTracked
{- Called when a transfer information file is removed. -}
-onDel :: Handler
-onDel file = case parseTransferFile (toRawFilePath file) of
+onDel :: Handler OsPath
+onDel file = case parseTransferFile file of
Nothing -> noop
Just t -> do
debug [ "transfer finishing:", show t]
, modifyHook = changed
, delDirHook = changed
}
- let dir = fromRawFilePath (parentDir (toRawFilePath flagfile))
+ let dir = parentDir flagfile
let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
void $ swapMVar mvar Started
return r
-changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
+changedFile :: UrlRenderer -> MVar WatcherState -> OsPath -> OsPath -> Maybe FileStatus -> Assistant ()
changedFile urlrenderer mvar flagfile file _status
| flagfile /= file = noop
| otherwise = do
import Config.GitConfig
import Utility.ThreadScheduler
import Logs.Location
+import qualified Utility.OsString as OS
import qualified Database.Keys
#ifndef mingw32_HOST_OS
import qualified Utility.Lsof as Lsof
delhook <- hook onDel
addsymlinkhook <- hook onAddSymlink
deldirhook <- hook onDelDir
- errhook <- hook onErr
+ errhook <- asIO2 onErr
let hooks = mkWatchHooks
{ addHook = addhook
, delHook = delhook
, addSymlinkHook = addsymlinkhook
, delDirHook = deldirhook
- , errHook = errhook
+ , errHook = Just errhook
}
scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig
- h <- liftIO $ watchDir "." ignored scanevents hooks startup
+ h <- liftIO $ watchDir (literalOsPath ".") ignored scanevents hooks startup
debug [ "watching", "."]
{- Let the DirWatcher thread run until signalled to pause it,
top <- liftAnnex $ fromRepo Git.repoPath
(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [] [top]
forM_ fs $ \f -> do
- let f' = fromRawFilePath f
- liftAnnex $ onDel' f'
- maybe noop recordChange =<< madeChange f' RmChange
+ liftAnnex $ onDel' f
+ maybe noop recordChange =<< madeChange f RmChange
void $ liftIO cleanup
liftAnnex $ showAction "started"
{- Hardcoded ignores, passed to the DirWatcher so it can avoid looking
- at the entire .git directory. Does not include .gitignores. -}
-ignored :: FilePath -> Bool
+ignored :: OsPath -> Bool
ignored = ig . takeFileName
where
- ig ".git" = True
- ig ".gitignore" = True
- ig ".gitattributes" = True
+ ig f
+ | f == literalOsPath ".git" = True
+ | f == literalOsPath ".gitignore" = True
+ | f == literalOsPath ".gitattributes" = True
#ifdef darwin_HOST_OS
- ig ".DS_Store" = True
+ | f == literlosPath ".DS_Store" = True
#endif
- ig _ = False
+ | otherwise = False
-unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
-unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) (toRawFilePath file))
+unlessIgnored :: OsPath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
+unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file)
( noChange
, a
)
-type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change)
+type Handler = OsPath -> Maybe FileStatus -> Assistant (Maybe Change)
{- Runs an action handler, and if there was a change, adds it to the ChangeChan.
-
- Exceptions are ignored, otherwise a whole watcher thread could be crashed.
-}
-runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler :: Handler -> OsPath -> Maybe FileStatus -> Assistant ()
runHandler handler file filestatus = void $ do
r <- tryIO <~> handler (normalize file) filestatus
case r of
Right (Just change) -> recordChange change
where
normalize f
- | "./" `isPrefixOf` file = drop 2 f
+ | literalOsPath "./" `OS.isPrefixOf` file = OS.drop 2 f
| otherwise = f
shouldRestage :: DaemonStatus -> Bool
where
addassociatedfile key file =
Database.Keys.addAssociatedFile key
- =<< inRepo (toTopFilePath (toRawFilePath file))
+ =<< inRepo (toTopFilePath file)
samefilestatus key file status = do
cache <- Database.Keys.getInodeCaches key
curr <- withTSDelta $ \delta ->
- liftIO $ toInodeCache delta (toRawFilePath file) status
+ liftIO $ toInodeCache delta file status
case (cache, curr) of
(_, Just c) -> elemInodeCaches c cache
([], Nothing) -> return True
_ -> return False
contentchanged oldkey file = do
Database.Keys.removeAssociatedFile oldkey
- =<< inRepo (toTopFilePath (toRawFilePath file))
+ =<< inRepo (toTopFilePath file)
unlessM (inAnnex oldkey) $
logStatus NoLiveUpdate oldkey InfoMissing
addlink file key = do
- mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file)
- liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
+ mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath file)
+ liftAnnex $ stagePointerFile file mode =<< hashPointerFile key
madeChange file $ LinkChange (Just key)
onAddFile'
- :: (Key -> FilePath -> Annex ())
- -> (Key -> FilePath -> Annex ())
- -> (FilePath -> Key -> Assistant (Maybe Change))
- -> (Key -> FilePath -> FileStatus -> Annex Bool)
+ :: (Key -> OsPath -> Annex ())
+ -> (Key -> OsPath -> Annex ())
+ -> (OsPath -> Key -> Assistant (Maybe Change))
+ -> (Key -> OsPath -> FileStatus -> Annex Bool)
-> Bool
-> Handler
onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do
- v <- liftAnnex $ catKeyFile (toRawFilePath file)
+ v <- liftAnnex $ catKeyFile file
case (v, fs) of
(Just key, Just filestatus) ->
ifM (liftAnnex $ samefilestatus key file filestatus)
, noChange
)
, guardSymlinkStandin (Just key) $ do
- debug ["changed", file]
+ debug ["changed", fromOsPath file]
liftAnnex $ contentchanged key file
pendingAddChange file
)
_ -> unlessIgnored file $
guardSymlinkStandin Nothing $ do
- debug ["add", file]
+ debug ["add", fromOsPath file]
pendingAddChange file
where
{- On a filesystem without symlinks, we'll get changes for regular
guardSymlinkStandin mk a
| symlinkssupported = a
| otherwise = do
- linktarget <- liftAnnex $ getAnnexLinkTarget $
- toRawFilePath file
+ linktarget <- liftAnnex $ getAnnexLinkTarget file
case linktarget of
Nothing -> a
Just lt -> do
-}
onAddSymlink :: Handler
onAddSymlink file filestatus = unlessIgnored file $ do
- linktarget <- liftIO (catchMaybeIO $ R.readSymbolicLink file')
- kv <- liftAnnex (lookupKey file')
+ linktarget <- liftIO $ catchMaybeIO $
+ R.readSymbolicLink (fromOsPath file)
+ kv <- liftAnnex (lookupKey file)
onAddSymlink' linktarget kv file filestatus
- where
- file' = toRawFilePath file
onAddSymlink' :: Maybe LinkTarget -> Maybe Key -> Handler
onAddSymlink' linktarget mk file filestatus = go mk
where
go (Just key) = do
- link <- liftAnnex $ calcRepo $ gitAnnexLink (toRawFilePath file) key
+ link <- liftAnnex $ fromOsPath <$> calcRepo (gitAnnexLink file key)
if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus
else do
- liftAnnex $ replaceWorkTreeFile (toRawFilePath file) $
+ liftAnnex $ replaceWorkTreeFile file $
makeAnnexLink link
addLink file link (Just key)
-- other symlink, not git-annex
ensurestaged Nothing _ = noChange
{- For speed, tries to reuse the existing blob for symlink target. -}
-addLink :: FilePath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
+addLink :: OsPath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
addLink file link mk = do
- debug ["add symlink", file]
+ debug ["add symlink", fromOsPath file]
liftAnnex $ do
- v <- catObjectDetails $ Ref $ encodeBS $ ':':file
+ v <- catObjectDetails $ Ref $ encodeBS $ ':':fromOsPath file
case v of
Just (currlink, sha, _type)
| L.fromStrict link == currlink ->
- stageSymlink (toRawFilePath file) sha
- _ -> stageSymlink (toRawFilePath file)
- =<< hashSymlink link
+ stageSymlink file sha
+ _ -> stageSymlink file =<< hashSymlink link
madeChange file $ LinkChange mk
onDel :: Handler
onDel file _ = do
- debug ["file deleted", file]
+ debug ["file deleted", fromOsPath file]
liftAnnex $ onDel' file
madeChange file RmChange
-onDel' :: FilePath -> Annex ()
+onDel' :: OsPath -> Annex ()
onDel' file = do
- topfile <- inRepo (toTopFilePath (toRawFilePath file))
+ topfile <- inRepo (toTopFilePath file)
withkey $ flip Database.Keys.removeAssociatedFile topfile
Annex.Queue.addUpdateIndex =<<
- inRepo (Git.UpdateIndex.unstageFile (toRawFilePath file))
+ inRepo (Git.UpdateIndex.unstageFile file)
where
- withkey a = maybe noop a =<< catKeyFile (toRawFilePath file)
+ withkey a = maybe noop a =<< catKeyFile file
{- A directory has been deleted, or moved, so tell git to remove anything
- that was inside it from its cache. Since it could reappear at any time,
- pairing up renamed files when the directory was renamed. -}
onDelDir :: Handler
onDelDir dir _ = do
- debug ["directory deleted", dir]
- (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [toRawFilePath dir]
- let fs' = map fromRawFilePath fs
+ debug ["directory deleted", fromOsPath dir]
+ (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [dir]
- liftAnnex $ mapM_ onDel' fs'
+ liftAnnex $ mapM_ onDel' fs
-- Get the events queued up as fast as possible, so the
-- committer sees them all in one block.
now <- liftIO getCurrentTime
- recordChanges $ map (\f -> Change now f RmChange) fs'
+ recordChanges $ map (\f -> Change now f RmChange) fs
void $ liftIO clean
noChange
{- Called when there's an error with inotify or kqueue. -}
-onErr :: Handler
+onErr :: String -> Maybe FileStatus -> Assistant ()
onErr msg _ = do
liftAnnex $ warning (UnquotedString msg)
void $ addAlert $ warningAlert "watcher" msg
- noChange
-> Maybe (IO Url)
-> Maybe HostName
-> Maybe PortNumber
- -> Maybe (Url -> FilePath -> IO ())
+ -> Maybe (Url -> OsPath -> IO ())
-> NamedThread
webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do
listenhost' <- if isJust listenhost
, return app
)
runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex
- then withTmpFile (toOsPath "webapp.html") $ \tmpfile h -> do
+ then withTmpFile (literalOsPath "webapp.html") $ \tmpfile h -> do
hClose h
- go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing
+ go tlssettings addr webapp tmpfile Nothing
else do
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
- go tlssettings addr webapp
- (fromRawFilePath htmlshim)
- (Just urlfile)
+ go tlssettings addr webapp htmlshim (Just urlfile)
where
-- The webapp thread does not wait for the startupSanityCheckThread
-- to finish, so that the user interface remains responsive while
thread = namedThreadUnchecked "WebApp"
getreldir
| noannex = return Nothing
- | otherwise = Just <$>
- (relHome . fromRawFilePath =<< absPath =<< getAnnex' (fromRepo repoPath))
+ | otherwise = Just . fromOsPath <$>
+ (relHome =<< absPath =<< getAnnex' (fromRepo repoPath))
go tlssettings addr webapp htmlshim urlfile = do
let url = myUrl tlssettings webapp addr
maybe noop (`writeFileProtected` url) urlfile
cert <- fromRepo gitAnnexWebCertificate
privkey <- fromRepo gitAnnexWebPrivKey
ifM (liftIO $ allM doesFileExist [cert, privkey])
- ( return $ Just $ TLS.tlsSettings cert privkey
+ ( return $ Just $ TLS.tlsSettings
+ (fromOsPath cert)
+ (fromOsPath privkey)
, return Nothing
)
AssociatedFile Nothing -> noop
AssociatedFile (Just af) -> void $
addAlert $ makeAlertFiller True $
- transferFileAlert direction True (fromRawFilePath af)
+ transferFileAlert direction True (fromOsPath af)
unless isdownload $
handleDrops
("object uploaded to " ++ show remote)
data Change
= Change
{ changeTime :: UTCTime
- , _changeFile :: FilePath
+ , _changeFile :: OsPath
, changeInfo :: ChangeInfo
}
| PendingAddChange
{ changeTime ::UTCTime
- , _changeFile :: FilePath
+ , _changeFile :: OsPath
}
| InProcessAddChange
{ changeTime ::UTCTime
changeInfoKey (LinkChange (Just k)) = Just k
changeInfoKey _ = Nothing
-changeFile :: Change -> FilePath
+changeFile :: Change -> OsPath
changeFile (Change _ f _) = f
changeFile (PendingAddChange _ f) = f
-changeFile (InProcessAddChange _ ld) = fromOsPath $ keyFilename $ keySource ld
+changeFile (InProcessAddChange _ ld) = keyFilename $ keySource ld
isPendingAddChange :: Change -> Bool
isPendingAddChange (PendingAddChange {}) = True
- than the remaining free disk space, or more than 1/10th the total
- disk space being unused keys all suggest a problem. -}
describeUnused' :: Bool -> Assistant (Maybe TenseText)
-describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog ""
+describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog (literalOsPath "")
where
go m = do
let num = M.size m
sumkeysize s k = s + fromMaybe 0 (fromKey keySize k)
- forpath a = inRepo $ liftIO . a . fromRawFilePath . Git.repoPath
+ forpath a = inRepo $ liftIO . a . fromOsPath . Git.repoPath
{- With a duration, expires all unused files that are older.
- With Nothing, expires *all* unused files. -}
expireUnused :: Maybe Duration -> Assistant ()
expireUnused duration = do
- m <- liftAnnex $ readUnusedLog ""
+ m <- liftAnnex $ readUnusedLog (literalOsPath "")
now <- liftIO getPOSIXTime
let oldkeys = M.keys $ M.filter (tooold now) m
forM_ oldkeys $ \k -> do
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Assistant.Upgrade where
import Utility.Tuple
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
+import qualified Utility.OsString as OS
import Data.Either
import qualified Data.Map as M
-import qualified System.FilePath.ByteString as P
{- Upgrade without interaction in the webapp. -}
unattendedUpgrade :: Assistant ()
hook <- asIO1 $ distributionDownloadComplete d dest cleanup
modifyDaemonStatus_ $ \s -> s
{ transferHook = M.insert k hook (transferHook s) }
- maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just (toRawFilePath f))) t)
+ maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t)
=<< liftAnnex (remoteFromUUID webUUID)
startTransfer t
k = mkKey $ const $ distributionKey d
u = distributionUrl d
- f = takeFileName u ++ " (for upgrade)"
+ f = takeFileName (toOsPath u) <> literalOsPath " (for upgrade)"
t = Transfer
{ transferDirection = Download
, transferUUID = webUUID
-
- Verifies the content of the downloaded key.
-}
-distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant ()
+distributionDownloadComplete :: GitAnnexDistribution -> OsPath -> Assistant () -> Transfer -> Assistant ()
distributionDownloadComplete d dest cleanup t
| transferDirection t == Download = do
debug ["finished downloading git-annex distribution"]
where
k = mkKey $ const $ distributionKey d
fsckit f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
- Nothing -> return $ Just (fromRawFilePath f)
+ Nothing -> return $ Just f
Just b -> case Types.Backend.verifyKeyContent b of
- Nothing -> return $ Just (fromRawFilePath f)
+ Nothing -> return $ Just f
Just verifier -> ifM (verifier k f)
- ( return $ Just (fromRawFilePath f)
+ ( return $ Just f
, return Nothing
)
go f = do
- and unpack the new distribution next to it (in a versioned directory).
- Then update the programFile to point to the new version.
-}
-upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant ()
+upgradeToDistribution :: OsPath -> Assistant () -> OsPath -> Assistant ()
upgradeToDistribution newdir cleanup distributionfile = do
liftIO $ createDirectoryIfMissing True newdir
(program, deleteold) <- unpack
postUpgrade url
where
changeprogram program = liftIO $ do
- unlessM (boolSystem program [Param "version"]) $
+ unlessM (boolSystem (fromOsPath program) [Param "version"]) $
giveup "New git-annex program failed to run! Not using."
pf <- programFile
- liftIO $ writeFile pf program
+ liftIO $ writeFile (fromOsPath pf) (fromOsPath program)
#ifdef darwin_HOST_OS
{- OS X uses a dmg, so mount it, and copy the contents into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
- withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) (toOsPath (toRawFilePath "git-annex.upgrade")) $ \tmpdir -> do
+ withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do
void $ boolSystem "hdiutil"
[ Param "attach", File distributionfile
- , Param "-mountpoint", File tmpdir
+ , Param "-mountpoint", File (fromOsPath tmpdir)
]
void $ boolSystem "cp"
[ Param "-R"
- , File $ tmpdir </> installBase </> "Contents"
+ , File $ fromOsPath $ tmpdir </> toOsPath installBase </> literalOsPath "Contents"
, File $ newdir
]
void $ boolSystem "hdiutil"
[ Param "eject"
- , File tmpdir
+ , File (fromOsPath tmpdir)
]
sanitycheck newdir
let deleteold = do
- deleteFromManifest $ olddir </> "Contents" </> "MacOS"
+ deleteFromManifest $ toOsPath olddir </> literalOsPath "Contents" </> literalOsPath "MacOS"
makeorigsymlink olddir
- return (newdir </> "Contents" </> "MacOS" </> "git-annex", deleteold)
+ return (newdir </> literalOsPath "Contents" </> literalOsPath "MacOS" </> literalOsPath "git-annex", deleteold)
#else
{- Linux uses a tarball (so could other POSIX systems), so
- untar it (into a temp directory) and move the directory
- into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
- withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) (toOsPath $ toRawFilePath "git-annex.upgrade") $ \tmpdir -> do
- let tarball = tmpdir </> "tar"
+ withTmpDirIn (parentDir newdir) (literalOsPath "git-annex.upgrade") $ \tmpdir -> do
+ let tarball = tmpdir </> literalOsPath "tar"
-- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent
-- decompression.
void $ boolSystem "sh"
[ Param "-c"
- , Param $ "zcat < " ++ shellEscape distributionfile ++
- " > " ++ shellEscape tarball
+ , Param $ "zcat < " ++ shellEscape (fromOsPath distributionfile) ++
+ " > " ++ shellEscape (fromOsPath tarball)
]
tarok <- boolSystem "tar"
[ Param "xf"
- , Param tarball
- , Param "--directory", File tmpdir
+ , Param (fromOsPath tarball)
+ , Param "--directory", File (fromOsPath tmpdir)
]
unless tarok $
- giveup $ "failed to untar " ++ distributionfile
- sanitycheck $ tmpdir </> installBase
- installby R.rename newdir (tmpdir </> installBase)
+ giveup $ "failed to untar " ++ fromOsPath distributionfile
+ sanitycheck $ tmpdir </> toOsPath installBase
+ installby R.rename newdir (tmpdir </> toOsPath installBase)
let deleteold = do
deleteFromManifest olddir
makeorigsymlink olddir
- return (newdir </> "git-annex", deleteold)
+ return (newdir </> literalOsPath "git-annex", deleteold)
installby a dstdir srcdir =
- mapM_ (\x -> a x (toRawFilePath dstdir P.</> P.takeFileName x))
- =<< dirContents (toRawFilePath srcdir)
+ mapM_ (\x -> a (fromOsPath x) (fromOsPath (dstdir </> takeFileName x)))
+ =<< dirContents srcdir
#endif
sanitycheck dir =
unlessM (doesDirectoryExist dir) $
- giveup $ "did not find " ++ dir ++ " in " ++ distributionfile
+ giveup $ "did not find " ++ fromOsPath dir ++ " in " ++ fromOsPath distributionfile
makeorigsymlink olddir = do
- let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) </> installBase
- removeWhenExistsWith R.removeLink (toRawFilePath origdir)
- R.createSymbolicLink (toRawFilePath newdir) (toRawFilePath origdir)
+ let origdir = parentDir olddir </> toOsPath installBase
+ removeWhenExistsWith removeFile origdir
+ R.createSymbolicLink (fromOsPath newdir) (fromOsPath origdir)
{- Finds where the old version was installed. -}
-oldVersionLocation :: IO FilePath
+oldVersionLocation :: IO OsPath
oldVersionLocation = readProgramFile >>= \case
Nothing -> giveup "Cannot find old distribution bundle; not upgrading."
Just pf -> do
- let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf
+ let pdir = parentDir pf
#ifdef darwin_HOST_OS
let dirs = splitDirectories pdir
{- It will probably be deep inside a git-annex.app directory. -}
- let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of
+ let olddir = case findIndex (literalOsPath "git-annex.app" `OS.isPrefixOf`) dirs of
Nothing -> pdir
Just i -> joinPath (take (i + 1) dirs)
#else
let olddir = pdir
#endif
- when (null olddir) $
- giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"
+ when (OS.null olddir) $
+ giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ fromOsPath pdir ++ ")"
return olddir
{- Finds a place to install the new version.
-
- The directory is created. If it already exists, returns Nothing.
-}
-newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath)
+newVersionLocation :: GitAnnexDistribution -> OsPath -> IO (Maybe OsPath)
newVersionLocation d olddir =
trymkdir newloc $ do
home <- myHomeDir
- trymkdir (home </> s) $
+ trymkdir (toOsPath home </> s) $
return Nothing
where
- s = installBase ++ "." ++ distributionVersion d
- topdir = fromRawFilePath $ parentDir $ toRawFilePath olddir
+ s = toOsPath $ installBase ++ "." ++ distributionVersion d
+ topdir = parentDir olddir
newloc = topdir </> s
trymkdir dir fallback =
(createDirectory dir >> return (Just dir))
#endif
#endif
-deleteFromManifest :: FilePath -> IO ()
+deleteFromManifest :: OsPath -> IO ()
deleteFromManifest dir = do
- fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
- mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs
- removeWhenExistsWith R.removeLink (toRawFilePath manifest)
- removeEmptyRecursive (toRawFilePath dir)
+ fs <- map (\f -> dir </> toOsPath f) . lines
+ <$> catchDefaultIO "" (readFile (fromOsPath manifest))
+ mapM_ (removeWhenExistsWith removeFile) fs
+ removeWhenExistsWith removeFile manifest
+ removeEmptyRecursive dir
where
- manifest = dir </> "git-annex.MANIFEST"
+ manifest = dir </> literalOsPath "git-annex.MANIFEST"
-removeEmptyRecursive :: RawFilePath -> IO ()
+removeEmptyRecursive :: OsPath -> IO ()
removeEmptyRecursive dir = do
mapM_ removeEmptyRecursive =<< dirContents dir
- void $ tryIO $ removeDirectory (fromRawFilePath dir)
+ void $ tryIO $ removeDirectory dir
{- This is a file that the UpgradeWatcher can watch for modifications to
- detect when git-annex has been upgraded.
-}
-upgradeFlagFile :: IO FilePath
+upgradeFlagFile :: IO OsPath
upgradeFlagFile = programPath
{- Sanity check to see if an upgrade is complete and the program is ready
program <- programPath
untilM (doesFileExist program <&&> nowriter program) $
threadDelaySeconds (Seconds 60)
- boolSystem program [Param "version"]
+ boolSystem (fromOsPath program) [Param "version"]
)
where
nowriter f = null
. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
. map snd3
- <$> Lsof.query [f]
+ <$> Lsof.query [fromOsPath f]
usingDistribution :: IO Bool
usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"
downloadDistributionInfo = do
uo <- liftAnnex Url.getUrlOptions
gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
- liftIO $ withTmpDir (toOsPath (toRawFilePath "git-annex.tmp")) $ \tmpdir -> do
- let infof = tmpdir </> "info"
- let sigf = infof ++ ".sig"
+ liftIO $ withTmpDir (literalOsPath "git-annex.tmp") $ \tmpdir -> do
+ let infof = tmpdir </> literalOsPath "info"
+ let sigf = infof <> literalOsPath ".sig"
ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo
<&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo)
<&&> verifyDistributionSig gpgcmd sigf)
( parseInfoFile . map decodeBS . fileLines'
- <$> F.readFile' (toOsPath (toRawFilePath infof))
+ <$> F.readFile' infof
, return Nothing
)
- The gpg keyring used to verify the signature is located in
- trustedkeys.gpg, next to the git-annex program.
-}
-verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool
+verifyDistributionSig :: GpgCmd -> OsPath -> IO Bool
verifyDistributionSig gpgcmd sig = readProgramFile >>= \case
Just p | isAbsolute p ->
- withUmask 0o0077 $ withTmpDir (toOsPath (toRawFilePath "git-annex-gpg.tmp")) $ \gpgtmp -> do
- let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
+ withUmask 0o0077 $ withTmpDir (literalOsPath "git-annex-gpg.tmp") $ \gpgtmp -> do
+ let trustedkeys = takeDirectory p </> literalOsPath "trustedkeys.gpg"
boolGpgCmd gpgcmd
[ Param "--no-default-keyring"
, Param "--no-auto-check-trustdb"
, Param "--no-options"
, Param "--homedir"
- , File gpgtmp
+ , File (fromOsPath gpgtmp)
, Param "--keyring"
- , File trustedkeys
+ , File (fromOsPath trustedkeys)
, Param "--verify"
- , File sig
+ , File (fromOsPath sig)
]
_ -> return False
sanityVerifierAForm $ SanityVerifier magicphrase
case result of
FormSuccess _ -> liftH $ do
- dir <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath
+ dir <- liftAnnex $ fromRepo Git.repoPath
liftIO $ removeAutoStartFile dir
{- Disable syncing to this repository, and all
rs <- syncRemotes <$> getDaemonStatus
mapM_ (\r -> changeSyncable (Just r) False) rs
- liftAnnex $ prepareRemoveAnnexDir (toRawFilePath dir)
- liftIO $ removeDirectoryRecursive . fromRawFilePath
- =<< absPath (toRawFilePath dir)
+ liftAnnex $ prepareRemoveAnnexDir dir
+ liftIO $ removeDirectoryRecursive =<< absPath dir
redirect ShutdownConfirmedR
_ -> $(widgetFile "configurators/delete/currentrepository")
Just t
| T.null t -> noop
| otherwise -> liftAnnex $ do
- let dir = takeBaseName $ T.unpack t
+ let dir = fromOsPath $ takeBaseName $ toOsPath $ T.unpack t
m <- remoteConfigMap
case M.lookup uuid m of
Nothing -> noop
case repoGroup cfg of
RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
Just d -> do
- top <- fromRawFilePath <$> fromRepo Git.repoPath
- createWorkTreeDirectory (toRawFilePath (top </> d))
+ top <- fromRepo Git.repoPath
+ createWorkTreeDirectory (top </> toOsPath d)
Nothing -> noop
_ -> noop
checkRepositoryPath p = do
home <- myHomeDir
let basepath = expandTilde home $ T.unpack p
- path <- fromRawFilePath <$> absPath (toRawFilePath basepath)
- let parent = fromRawFilePath $ parentDir (toRawFilePath path)
+ path <- absPath basepath
+ let parent = parentDir path
problems <- catMaybes <$> mapM runcheck
- [ (return $ path == "/", "Enter the full path to use for the repository.")
- , (return $ all isSpace basepath, "A blank path? Seems unlikely.")
+ [ (return $ path == literalOsPath "/", "Enter the full path to use for the repository.")
+ , (return $ all isSpace (fromOsPath basepath :: FilePath), "A blank path? Seems unlikely.")
, (doesFileExist path, "A file already exists with that name.")
- , (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
+ , (return $ fromOsPath path == home, "Sorry, using git-annex for your whole home directory is not currently supported.")
, (not <$> doesDirectoryExist parent, "Parent directory does not exist.")
, (not <$> canWrite path, "Cannot write a repository there.")
]
return $
case headMaybe problems of
- Nothing -> Right $ Just $ T.pack basepath
+ Nothing -> Right $ Just $ T.pack $ fromOsPath basepath
Just prob -> Left prob
where
runcheck (chk, msg) = ifM chk ( return $ Just msg, return Nothing )
- expandTilde home ('~':'/':path) = home </> path
- expandTilde _ path = path
+ expandTilde home ('~':'/':path) = toOsPath home </> toOsPath path
+ expandTilde _ path = toOsPath path
{- On first run, if run in the home directory, default to putting it in
- ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
- the user probably wants to put it there. Unless that directory
- contains a git-annex file, in which case the user has probably
- browsed to a directory with git-annex and run it from there. -}
-defaultRepositoryPath :: Bool -> IO FilePath
+defaultRepositoryPath :: Bool -> IO OsPath
defaultRepositoryPath firstrun = do
#ifndef mingw32_HOST_OS
home <- myHomeDir
currdir <- liftIO getCurrentDirectory
- if home == currdir && firstrun
+ if toOsPath home == currdir && firstrun
then inhome
else ifM (legit currdir <&&> canWrite currdir)
( return currdir
where
inhome = ifM osAndroid
( do
- home <- myHomeDir
- let storageshared = home </> "storage" </> "shared"
+ home <- toOsPath <$> myHomeDir
+ let storageshared = home </> literalOsPath "storage" </> literalOsPath "shared"
ifM (doesDirectoryExist storageshared)
( relHome $ storageshared </> gitAnnexAssistantDefaultDir
- , return $ "~" </> gitAnnexAssistantDefaultDir
+ , return $ literalOsPath "~" </> gitAnnexAssistantDefaultDir
)
, do
- desktop <- userDesktopDir
+ desktop <- toOsPath <$> userDesktopDir
ifM (doesDirectoryExist desktop <&&> canWrite desktop)
( relHome $ desktop </> gitAnnexAssistantDefaultDir
- , return $ "~" </> gitAnnexAssistantDefaultDir
+ , return $ literalOsPath "~" </> gitAnnexAssistantDefaultDir
)
)
#ifndef mingw32_HOST_OS
-- Avoid using eg, standalone build's git-annex.linux/ directory
-- when run from there.
- legit d = not <$> doesFileExist (d </> "git-annex")
+ legit d = not <$> doesFileExist (d </> literalOsPath "git-annex")
#endif
-newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
+newRepositoryForm :: OsPath -> Hamlet.Html -> MkMForm RepositoryPath
newRepositoryForm defpath msg = do
(pathRes, pathView) <- mreq (repositoryPathField True) (bfs "")
- (Just $ T.pack $ addTrailingPathSeparator defpath)
+ (Just $ T.pack $ fromOsPath $ addTrailingPathSeparator defpath)
let (err, errmsg) = case pathRes of
FormMissing -> (False, "")
FormFailure l -> (True, concatMap T.unpack l)
((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path
case res of
FormSuccess (RepositoryPath p) -> liftH $
- startFullAssistant (T.unpack p) ClientGroup Nothing
+ startFullAssistant (toOsPath $ T.unpack p) ClientGroup Nothing
_ -> $(widgetFile "configurators/newrepository/first")
getAndroidCameraRepositoryR :: Handler ()
getAndroidCameraRepositoryR = do
home <- liftIO myHomeDir
- let dcim = home </> "storage" </> "dcim"
+ let dcim = toOsPath home </> literalOsPath "storage" </> literalOsPath "dcim"
startFullAssistant dcim SourceGroup $ Just addignore
where
addignore = do
- liftIO $ unlessM (doesFileExist ".gitignore") $
+ liftIO $ unlessM (doesFileExist $ literalOsPath ".gitignore") $
writeFile ".gitignore" ".thumbnails"
void $ inRepo $
Git.Command.runBool [Param "add", File ".gitignore"]
getNewRepositoryR = postNewRepositoryR
postNewRepositoryR :: Handler Html
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
- home <- liftIO myHomeDir
+ home <- toOsPath <$> liftIO myHomeDir
((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm home
case res of
FormSuccess (RepositoryPath p) -> do
- let path = T.unpack p
+ let path = toOsPath (T.unpack p)
isnew <- liftIO $ makeRepo path False
u <- liftIO $ initRepo isnew True path Nothing (Just ClientGroup)
liftIO $ addAutoStartFile path
liftIO $ startAssistant path
- askcombine u path
+ askcombine u (fromOsPath path)
_ -> $(widgetFile "configurators/newrepository")
where
askcombine newrepouuid newrepopath = do
- newrepo <- liftIO $ relHome newrepopath
+ newrepo' <- liftIO $ relHome (toOsPath newrepopath)
+ let newrepo = fromOsPath newrepo' :: FilePath
mainrepo <- fromJust . relDir <$> liftH getYesod
$(widgetFile "configurators/newrepository/combine")
getCombineRepositoryR :: FilePath -> UUID -> Handler Html
getCombineRepositoryR newrepopath newrepouuid = do
- liftAssistant . immediateSyncRemote =<< combineRepos newrepopath remotename
+ liftAssistant . immediateSyncRemote
+ =<< combineRepos (toOsPath newrepopath) remotename
redirect $ EditRepositoryR $ RepoUUID newrepouuid
where
- remotename = takeFileName newrepopath
+ remotename = fromOsPath $ takeFileName $ toOsPath newrepopath
selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive
<$> pure Nothing
<*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing
<*> areq textField (bfs "Use this directory on the drive:")
- (Just $ T.pack gitAnnexAssistantDefaultDir)
+ (Just $ T.pack $ fromOsPath gitAnnexAssistantDefaultDir)
where
pairs = zip (map describe drives) (map mountPoint drives)
describe drive = case diskFree drive of
]
onlywritable = [whamlet|This list only includes drives you can write to.|]
-removableDriveRepository :: RemovableDrive -> FilePath
+removableDriveRepository :: RemovableDrive -> OsPath
removableDriveRepository drive =
- T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive)
+ toOsPath (T.unpack (mountPoint drive)) </> toOsPath (T.unpack (driveRepoPath drive))
{- Adding a removable drive. -}
getAddDriveR :: Handler Html
postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
removabledrives <- liftIO driveList
writabledrives <- liftIO $
- filterM (canWrite . T.unpack . mountPoint) removabledrives
+ filterM (canWrite . toOsPath . T.unpack . mountPoint) removabledrives
((res, form), enctype) <- liftH $ runFormPostNoToken $
selectDriveForm (sort writabledrives)
case res of
mu <- liftIO $ probeUUID dir
case mu of
Nothing -> maybe askcombine isknownuuid
- =<< liftAnnex (probeGCryptRemoteUUID dir)
+ =<< liftAnnex (probeGCryptRemoteUUID $ fromOsPath dir)
Just driveuuid -> isknownuuid driveuuid
, newrepo
)
where
go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do
r <- liftAnnex $ addRemote $
- makeGCryptRemote remotename dir keyid
+ makeGCryptRemote remotename (fromOsPath dir) keyid
return (Types.Remote.uuid r, r)
- go NoRepoKey = checkGCryptRepoEncryption dir makeunencrypted makeunencrypted $ do
- mu <- liftAnnex $ probeGCryptRemoteUUID dir
+ go NoRepoKey = checkGCryptRepoEncryption (fromOsPath dir) makeunencrypted makeunencrypted $ do
+ mu <- liftAnnex $ probeGCryptRemoteUUID (fromOsPath dir)
case mu of
Just u -> enableexistinggcryptremote u
Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
enableexistinggcryptremote u = do
- remotename' <- liftAnnex $ getGCryptRemoteName u dir
+ remotename' <- liftAnnex $ getGCryptRemoteName u (fromOsPath dir)
makewith $ const $ do
r <- liftAnnex $ addRemote $
enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList
- [(Proposed "gitrepo", Proposed dir)]
+ [(Proposed "gitrepo", Proposed (fromOsPath dir))]
return (u, r)
{- Making a new unencrypted repo, or combining with an existing one. -}
makeunencrypted = makewith $ \isnew -> (,)
liftAnnex $ defaultStandardGroup u TransferGroup
liftAssistant $ immediateSyncRemote r
redirect $ EditNewRepositoryR u
- mountpoint = T.unpack (mountPoint drive)
+ mountpoint = toOsPath $ T.unpack (mountPoint drive)
dir = removableDriveRepository drive
- remotename = takeFileName mountpoint
+ remotename = fromOsPath $ takeFileName mountpoint
{- Each repository is made a remote of the other.
- Next call syncRemote to get them in sync. -}
-combineRepos :: FilePath -> String -> Handler Remote
+combineRepos :: OsPath -> String -> Handler Remote
combineRepos dir name = liftAnnex $ do
hostname <- fromMaybe "host" <$> liftIO getHostname
- mylocation <- fromRepo Git.repoLocation
- mypath <- liftIO $ fromRawFilePath <$> relPathDirToFile
- (toRawFilePath dir)
- (toRawFilePath mylocation)
- liftIO $ inDir dir $ void $ makeGitRemote hostname mypath
- addRemote $ makeGitRemote name dir
+ mylocation <- fromRepo Git.repoPath
+ mypath <- liftIO $ relPathDirToFile dir mylocation
+ liftIO $ inDir dir $ void $ makeGitRemote hostname (fromOsPath mypath)
+ addRemote $ makeGitRemote name (fromOsPath dir)
getEnableDirectoryR :: UUID -> Handler Html
getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
genRemovableDrive dir = RemovableDrive
<$> getDiskFree dir
<*> pure (T.pack dir)
- <*> pure (T.pack gitAnnexAssistantDefaultDir)
+ <*> pure (T.pack $ fromOsPath gitAnnexAssistantDefaultDir)
{- Bootstraps from first run mode to a fully running assistant in a
- repository, by running the postFirstRun callback, which returns the
- url to the new webapp. -}
-startFullAssistant :: FilePath -> StandardGroup -> Maybe (Annex ())-> Handler ()
+startFullAssistant :: OsPath -> StandardGroup -> Maybe (Annex ())-> Handler ()
startFullAssistant path repogroup setup = do
webapp <- getYesod
url <- liftIO $ do
-
- The directory may be in the process of being created; if so
- the parent directory is checked instead. -}
-canWrite :: FilePath -> IO Bool
+canWrite :: OsPath -> IO Bool
canWrite dir = do
tocheck <- ifM (doesDirectoryExist dir)
( return dir
- , return $ fromRawFilePath $ parentDir $ toRawFilePath dir
+ , return $ parentDir dir
)
- catchBoolIO $ R.fileAccess (toRawFilePath tocheck) False True False
+ catchBoolIO $ R.fileAccess (fromOsPath tocheck) False True False
{- Gets the UUID of the git repo at a location, which may not exist, or
- not be a git-annex repo. -}
-probeUUID :: FilePath -> IO (Maybe UUID)
+probeUUID :: OsPath -> IO (Maybe UUID)
probeUUID dir = catchDefaultIO Nothing $ inDir dir $ do
u <- getUUID
return $ if u == NoUUID then Nothing else Just u
enableTor :: Handler ()
enableTor = do
- gitannex <- liftIO programPath
+ gitannex <- fromOsPath <$> liftIO programPath
(transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing
if ok
-- Reload remotedameon so it's serving the tor hidden
postFinishLocalPairR :: PairMsg -> Handler Html
#ifdef WITH_PAIRING
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
- repodir <- liftH $ fromRawFilePath . repoPath <$> liftAnnex gitRepo
+ repodir <- liftH $ repoPath <$> liftAnnex gitRepo
liftIO $ setup repodir
startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
where
import Assistant.Upgrade
import qualified Data.Text as T
-import qualified System.FilePath.ByteString as P
data PrefsForm = PrefsForm
{ diskReserve :: Text
unsetConfig (annexConfig "numcopies") -- deprecated
setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p)
unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
- here <- fromRawFilePath <$> fromRepo Git.repoPath
+ here <- fromRepo Git.repoPath
liftIO $ if autoStart p
then addAutoStartFile here
else removeAutoStartFile here
inAutoStartFile :: Annex Bool
inAutoStartFile = do
here <- liftIO . absPath =<< fromRepo Git.repoPath
- any (`P.equalFilePath` here) . map toRawFilePath
- <$> liftIO readAutoStartFile
+ any (`equalFilePath` here) <$> liftIO readAutoStartFile
, sshDirectory = fromMaybe "" $ inputDirectory s
, sshRepoName = genSshRepoName
(T.unpack $ fromJust $ inputHostname s)
- (maybe "" T.unpack $ inputDirectory s)
+ (toOsPath (maybe "" T.unpack $ inputDirectory s))
, sshPort = inputPort s
, needsPubKey = False
, sshCapabilities = [] -- untested
<*> aopt check_username (bfs "User name") (Just $ inputUsername d)
<*> areq (selectFieldList authmethods) (bfs "Authenticate with") (Just $ inputAuthMethod d)
<*> aopt passwordField (bfs "Password") Nothing
- <*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory d)
+ <*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack $ fromOsPath gitAnnexAssistantDefaultDir) $ inputDirectory d)
<*> areq intField (bfs "Port") (Just $ inputPort d)
authmethods :: [(Text, AuthMethod)]
v <- getCachedCred login
liftIO $ case v of
Nothing -> go [passwordprompts 0] Nothing
- Just pass -> withTmpFile (toOsPath "ssh") $ \passfile h -> do
+ Just pass -> withTmpFile (literalOsPath "ssh") $ \passfile h -> do
hClose h
- writeFileProtected (fromOsPath passfile) pass
+ writeFileProtected passfile pass
environ <- getEnvironment
let environ' = addEntries
- [ ("SSH_ASKPASS", program)
- , (sshAskPassEnv, fromRawFilePath $ fromOsPath passfile)
+ [ ("SSH_ASKPASS", fromOsPath program)
+ , (sshAskPassEnv, fromOsPath passfile)
, ("DISPLAY", ":0")
] environ
go [passwordprompts 1] (Just environ')
]
, if needsinit then Just (wrapCommand "git annex init") else Nothing
, if needsPubKey origsshdata
- then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
+ then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) (toOsPath remotedir) . sshPubKey <$> keypair
else Nothing
]
rsynconly = onlyCapability origsshdata RsyncCapable
|]
go sshinput = do
let reponame = genSshRepoName "rsync.net"
- (maybe "" T.unpack $ inputDirectory sshinput)
+ (toOsPath (maybe "" T.unpack $ inputDirectory sshinput))
prepRsyncNet sshinput reponame $ \sshdata -> inpage $
checkExistingGCrypt sshdata $ do
redirect ConfigurationR
_ -> do
munuseddesc <- liftAssistant describeUnused
- ts <- liftAnnex $ dateUnusedLog ""
+ ts <- liftAnnex $ dateUnusedLog (literalOsPath "")
mlastchecked <- case ts of
Nothing -> pure Nothing
Just t -> Just <$> liftIO (durationSince t)
getLogR :: Handler Html
getLogR = page "Logs" Nothing $ do
logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
- logs <- liftIO $ listLogs (fromRawFilePath logfile)
+ logs <- liftIO $ listLogs (fromOsPath logfile)
logcontent <- liftIO $ concat <$> mapM readFile logs
$(widgetFile "control/log")
transferPaused info || isNothing (startedTime info)
desc transfer info = case associatedFile info of
AssociatedFile Nothing -> serializeKey $ transferKey transfer
- AssociatedFile (Just af) -> fromRawFilePath af
+ AssociatedFile (Just af) -> fromOsPath af
{- Simplifies a list of transfers, avoiding display of redundant
- equivalent transfers. -}
- blocking the response to the browser on it. -}
openFileBrowser :: Handler Bool
openFileBrowser = do
- path <- fromRawFilePath
+ path <- fromOsPath
<$> (liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath))
#ifdef darwin_HOST_OS
let cmd = "open"
{- The full license info may be included in a file on disk that can
- be read in and displayed. -}
-licenseFile :: IO (Maybe FilePath)
+licenseFile :: IO (Maybe OsPath)
licenseFile = do
base <- standaloneAppBase
- return $ (</> "LICENSE") <$> base
+ return $ (</> literalOsPath "LICENSE") <$> base
getAboutR :: Handler Html
getAboutR = page "About git-annex" (Just About) $ do
Just f -> customPage (Just About) $ do
-- no sidebar, just pages of legalese..
setTitle "License"
- license <- liftIO $ readFile f
+ license <- liftIO $ readFile (fromOsPath f)
$(widgetFile "documentation/license")
getRepoGroupR :: Handler Html
import Config.Files.AutoStart
import Utility.Yesod
import Assistant.Restart
-import qualified Utility.RawFilePath as R
getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do
listOtherRepos :: IO [(String, String)]
listOtherRepos = do
dirs <- readAutoStartFile
- pwd <- R.getCurrentDirectory
+ pwd <- getCurrentDirectory
gooddirs <- filterM isrepo $
- filter (\d -> not $ toRawFilePath d `dirContains` pwd) dirs
+ filter (\d -> not $ d `dirContains` pwd) dirs
names <- mapM relHome gooddirs
- return $ sort $ zip names gooddirs
+ return $ sort $ zip (map fromOsPath names) (map fromOsPath gooddirs)
where
- isrepo d = doesDirectoryExist (d </> ".git")
+ isrepo d = doesDirectoryExist (d </> literalOsPath ".git")
getSwitchToRepositoryR :: FilePath -> Handler Html
getSwitchToRepositoryR repo = do
- liftIO $ addAutoStartFile repo -- make this the new default repo
- redirect =<< liftIO (newAssistantUrl repo)
+ let repo' = toOsPath repo
+ liftIO $ addAutoStartFile repo' -- make this the new default repo
+ redirect =<< liftIO (newAssistantUrl repo')
dirs <- liftIO readAutoStartFile
when (null dirs) $ do
f <- autoStartFile
- giveup $ "Nothing listed in " ++ f
- program <- programPath
+ giveup $ "Nothing listed in " ++ fromOsPath f
+ program <- fromOsPath <$> programPath
haveionice <- pure BuildInfo.ionice <&&> inSearchPath "ionice"
pids <- forM dirs $ \d -> do
- putStrLn $ "git-annex autostart in " ++ d
+ putStrLn $ "git-annex autostart in " ++ fromOsPath d
mpid <- catchMaybeIO $ go haveionice program d
if foregroundDaemonOption (daemonOptions o)
then return mpid
autoStop :: IO ()
autoStop = do
dirs <- liftIO readAutoStartFile
- program <- programPath
+ program <- fromOsPath <$> programPath
forM_ dirs $ \d -> do
- putStrLn $ "git-annex autostop in " ++ d
+ putStrLn $ "git-annex autostop in " ++ fromOsPath d
tryIO (setCurrentDirectory d) >>= \case
Right () -> ifM (boolSystem program [Param "assistant", Param "--stop"])
( putStrLn "ok"
listenPort' <- if isJust (listenPort o)
then pure (listenPort o)
else annexPort <$> Annex.getGitConfig
- ifM (checkpid <&&> checkshim (fromRawFilePath f))
+ ifM (checkpid <&&> checkshim f)
( if isJust (listenAddress o) || isJust (listenPort o)
then giveup "The assistant is already running, so --listen and --port cannot be used."
else do
- url <- liftIO . readFile . fromRawFilePath
+ url <- liftIO . readFile . fromOsPath
=<< fromRepo gitAnnexUrlFile
liftIO $ if isJust listenAddress'
then putStrLn url
- else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing
+ else liftIO $ openBrowser browser f url Nothing Nothing
, do
startDaemon True True Nothing cannotrun listenAddress' listenPort' $ Just $
\origout origerr url htmlshim ->
)
checkpid = do
pidfile <- fromRepo gitAnnexPidFile
- liftIO $ isJust <$> checkDaemon (fromRawFilePath pidfile)
+ liftIO $ isJust <$> checkDaemon pidfile
checkshim f = liftIO $ doesFileExist f
notinitialized = do
g <- Annex.gitRepo
- liftIO $ cannotStartIn (Git.repoLocation g) "repository has not been initialized by git-annex"
+ liftIO $ cannotStartIn (Git.repoPath g) "repository has not been initialized by git-annex"
liftIO $ firstRun o
{- If HOME is a git repo, even if it's initialized for git-annex,
notHome = do
g <- Annex.gitRepo
d <- liftIO $ absPath (Git.repoPath g)
- h <- liftIO $ absPath . toRawFilePath =<< myHomeDir
+ h <- liftIO $ absPath . toOsPath =<< myHomeDir
return (d /= h)
{- When run without a repo, start the first available listed repository in
go ds
Right state -> void $ Annex.eval state $ do
whenM (fromRepo Git.repoIsLocalBare) $
- giveup $ d ++ " is a bare git repository, cannot run the webapp in it"
+ giveup $ fromOsPath d ++ " is a bare git repository, cannot run the webapp in it"
r <- callCommandAction $
start' False o
quiesce False
return r
-cannotStartIn :: FilePath -> String -> IO ()
-cannotStartIn d reason = warningIO $ "unable to start webapp in repository " ++ d ++ ": " ++ reason
+cannotStartIn :: OsPath -> String -> IO ()
+cannotStartIn d reason = warningIO $
+ "unable to start webapp in repository " ++ fromOsPath d ++ ": " ++ reason
{- Run the webapp without a repository, which prompts the user, makes one,
- changes to it, starts the regular assistant, and redirects the
(Just $ sendurlback v)
sendurlback v _origout _origerr url _htmlshim = putMVar v url
-openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
+openBrowser :: Maybe OsPath -> OsPath -> String -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser mcmd htmlshim realurl outh errh = do
- htmlshim' <- fromRawFilePath <$> absPath (toRawFilePath htmlshim)
+ htmlshim' <- absPath htmlshim
openBrowser' mcmd htmlshim' realurl outh errh
-openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()
+openBrowser' :: Maybe OsPath -> OsPath -> String -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser' mcmd htmlshim realurl outh errh =
ifM osAndroid
{- Android does not support file:// urls well, but neither
where
runbrowser url = do
let p = case mcmd of
- Just c -> proc c [url]
+ Just c -> proc (fromOsPath c) [url]
Nothing ->
#ifndef mingw32_HOST_OS
browserProc url
{- Windows hack to avoid using the full path,
- which might contain spaces that cause problems
- for browserProc. -}
- (browserProc (takeFileName htmlshim))
- { cwd = Just (takeDirectory htmlshim) }
+ (browserProc (fromOsPath (takeFileName htmlshim)))
+ { cwd = Just (fromOsPath (takeDirectory htmlshim)) }
#endif
hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
hFlush stdout
hPutStrLn (fromMaybe stderr errh) "failed to start web browser"
{- web.browser is a generic git config setting for a web browser program -}
-webBrowser :: Git.Repo -> Maybe FilePath
+webBrowser :: Git.Repo -> Maybe OsPath
webBrowser = fmap fromConfigValue <$> Git.Config.getMaybe "web.browser"
-fileUrl :: FilePath -> String
-fileUrl file = "file://" ++ file
+fileUrl :: OsPath -> String
+fileUrl file = "file://" ++ fromOsPath file
{- Creates a html shim file that's used to redirect into the webapp,
- to avoid exposing the secret token when launching the web browser. -}
-writeHtmlShim :: String -> String -> FilePath -> IO ()
+writeHtmlShim :: String -> String -> OsPath -> IO ()
writeHtmlShim title url file =
- viaTmp (writeFileProtected)
- (toOsPath $ toRawFilePath file)
- (genHtmlShim title url)
+ viaTmp (writeFileProtected) file (genHtmlShim title url)
genHtmlShim :: String -> String -> String
genHtmlShim title url = unlines
projects / git-annex.git / commitdiff